home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / ttt.stk < prev    next >
Encoding:
Text File  |  1996-07-22  |  17.7 KB  |  666 lines
  1. #!/bin/sh
  2. :;  exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;
  4. ;;; 3D Tic-Tac-Toe
  5. ;;; written by Edin "Dino" Hodzic
  6. ;;; mailto:ehodzic@scu.edu
  7.  
  8. ;;; last update: Jun 30, 1996.
  9.  
  10. ;;; This is a free program written for STk 3.0.
  11.  
  12. ;;; GUI related variables
  13.  
  14. ; sizes and positions
  15. (define cell-width 15)
  16. (define cell-height 15)
  17. (define distance 15)            ; vertical between planes
  18. (define x0 distance)
  19. (define y0 distance)
  20. (define modx0 0)                ; actual x0
  21. (define mody0 0)                ; actual y0
  22. (define angle 45)            ; plane drawing angle
  23. (define delx 0)                ; x change from row to row
  24. (define dely 0)                ; y change from row to row
  25.  
  26. ; colors
  27. (if (eq? (winfo 'visual '.) 'staticgray)
  28.     (begin
  29.       (define grid-color 'black)
  30.       (define sign-color 'black)
  31.       (define win-sign-color 'black)
  32.       (define last-move-sign-color 'black)
  33.       (define show-line-color 'black))
  34.     (begin
  35.       (define grid-color 'white)
  36.       (define sign-color 'navy)
  37.       (define win-sign-color 'red)
  38.       (define last-move-sign-color 'blue)
  39.       (define show-line-color 'magenta)))
  40.  
  41. ;;; GUI related functions
  42.  
  43. (define (set-angle! ang)
  44.   (set! angle ang)
  45.   (let* ((pi (* (atan 1) 4))
  46.      (rangle (* angle (/ pi 180))))
  47.     (set! delx (round (- (* cell-height (cos rangle)))))
  48.     (set! dely (round (* cell-height (sin rangle))))))
  49.  
  50. ; draw a 4x4 plane with x0 y0 reference point (in the canvas)
  51. (define (draw-plane x0 y0)
  52.   (for-each-5
  53.    (lambda (i)
  54.      (let* ((rowx1 (+ x0 (* delx i)))
  55.         (rowy1 (+ y0 (* dely i)))
  56.         (rowx2 (+ rowx1 (* cell-width 4)))
  57.         (rowy2 rowy1)
  58.         (colx1 (+ x0 (* cell-width i)))
  59.         (coly1 y0)
  60.         (colx2 (+ colx1 (* delx 4)))
  61.         (coly2 (+ y0 (* dely 4))))
  62.        (.board 'create 'line        ; horizontal line
  63.            rowx1 rowy1 
  64.            rowx2 rowy2
  65.            :fill grid-color
  66.            :width 1)
  67.        (.board 'create 'line        ; vertical line
  68.            colx1 coly1
  69.            colx2 coly2
  70.            :fill grid-color
  71.            :width 1)
  72.        (if (= i 4)
  73.        (begin
  74.          (.board 'create 'line    ; plane bottom horizontal line
  75.              rowx1 (+ 2 rowy1)
  76.              rowx2 (+ 2 rowy2)
  77.              :fill grid-color
  78.              :width 2)
  79.          (.board 'create 'line    ; plane side vertical line
  80.              colx1 (+ 2 coly1)
  81.              colx2 (+ 2 coly2)
  82.              :fill grid-color
  83.              :width 2)))))))
  84.  
  85. ; screen coordinates to point
  86. (define (screenxy->point x y)
  87.   (let* ((canx (.board 'canvasx x))
  88.      (cany (.board 'canvasy y))
  89.      (x0 modx0)
  90.      (y0 mody0)
  91.      (plane (inexact->exact 
  92.          (floor (/ (- cany y0)
  93.                (+ (* dely 4) distance)))))
  94.      (rowq (/ (- cany y0 (+ (* dely 4 plane) (* distance plane)))
  95.           dely))
  96.      (row (inexact->exact (floor rowq)))
  97.      (col (inexact->exact (floor 
  98.                    (/ (- canx (+ x0 (* delx rowq))) 
  99.                   cell-width)))))
  100.     (if (and (<= 0 plane 3) (<= 0 row 3) (<= 0 col 3))
  101.     (make-point plane row col)
  102.     #f)))
  103.  
  104. ; north-west corner of a point to board screen coordinates
  105. (define (point->screen point)
  106.   (let ((plane (point-plane point))
  107.     (row (point-row point))
  108.     (col (point-column point)))
  109.     (cons (inexact->exact (+ modx0 (* delx row) 
  110.                  (* cell-width col)))
  111.       (inexact->exact (+ mody0 (* plane dely 4) 
  112.                  (* row dely) (* plane distance))))))
  113.  
  114. ; center of a point to board screen coordinates
  115. (define (point->screen-center point)
  116.   (let* ((scr (point->screen point))
  117.      (x (inexact->exact (+ (car scr) (* cell-width 0.5) (* delx 0.5))))
  118.      (y (inexact->exact (+ (cdr scr) (* dely 0.5)))))
  119.     (cons x y)))
  120.  
  121. ; the last point for which lines have been shown
  122. (define shown-lines-point #f)
  123.  
  124. ; line showing flag
  125. (define show-lines-flag #f)
  126.  
  127. (define (show-lines point)
  128.   (if (and point (or (not shown-lines-point)
  129.              (not (point-equal? point shown-lines-point))))
  130.       (begin
  131.     (set! shown-lines-point point)
  132.     (.board 'delete "lines")
  133.     (for-each
  134.      (lambda (line)
  135.        (let* ((first (line 0))
  136.           (last (line 3))
  137.           (scr-first (point->screen-center first))
  138.           (scr-last (point->screen-center last)))
  139.          (.board 'create 'line    ; draw the line
  140.              (car scr-first) (cdr scr-first)
  141.              (car scr-last) (cdr scr-last)
  142.              :tag  "lines"
  143.              :width 0
  144.              :fill show-line-color)
  145.          (for-each-point-in-line    ; mark the point thru which line goes
  146.           (lambda (point)
  147.         (let ((scr (point->screen-center point)))
  148.           (.board 'create 'text (car scr) (cdr scr)
  149.               :text "="
  150.               :tag "lines"
  151.               :fill show-line-color)))
  152.           line)))
  153.      (point-lines point))))
  154.   (if (not show-lines-flag)
  155.       (.board 'delete "lines")))
  156.  
  157. (define (toggle-show-lines point)
  158.   (set! show-lines-flag (not show-lines-flag))
  159.   (set! shown-lines-point #f)
  160.   (note (string-append "Line showing is " (if show-lines-flag "ON" "OFF")))
  161.   (show-lines point))
  162.  
  163. ; show the move on the board
  164. (define (draw-move point val . high)
  165.   (let* ((scr (point->screen-center point))
  166.      (x (car scr))
  167.      (y (cdr scr)))
  168.     (.board 'delete (point->string point))
  169.     (.board 'create 'text x y
  170.         :text (value->sign val) 
  171.         :tag (point->string point)
  172.         :fill (cond
  173.            ((or (null? high) (eq? (car high) 'plain)) sign-color)
  174.            ((equal? (car high) 'highlight) win-sign-color)
  175.            ((equal? (car high) 'last) last-move-sign-color)
  176.            (#t sign-color)))))
  177.  
  178. (define (clear-move point)
  179.   (.board 'delete (point->string point)))
  180.  
  181. ; draw the 3D 4x4x4 board
  182. (define (draw-board)
  183.   (catch (entry '.note :state 'disabled))
  184.   (catch (canvas '.board :relief 'sunken :borderwidth 2))
  185.   (catch
  186.    (menubutton '.mb :text "File")
  187.    (menu '.mb.m)
  188.    (.mb.m 'add 'command :label "New Game" :command new-game)
  189.    (.mb.m 'add 'command :label "Take Back" :command take-back-move)
  190.    (.mb.m 'add 'command :label "Toggle Lines" 
  191.       :command (lambda () (toggle-show-lines #f)))
  192.    (.mb.m 'add 'command :label "Resize" :command tune)
  193.    (.mb.m 'add 'command :label "Quit" :command (lambda () (quit)))
  194.    (.mb 'config :menu '.mb.m))
  195.   (catch
  196.    (menubutton '.help :text "Help")
  197.    (menu '.help.m)
  198.    (.help.m 'add 'command :label "About" :command about)
  199.    (.help 'config :menu '.help.m))
  200.   (.board 'delete 'all)
  201.   (bind '.board "<1>" (lambda (x y) (action x y)))
  202.   (bind '.board "<2>" take-back-move)
  203.   (bind '.board "<3>" tune)
  204.   (bind '.board "<Any-Motion>" 
  205.     (lambda (x y) (show-lines (screenxy->point x y))))
  206.   (bind '.board "<l>" 
  207.     (lambda (x y) (toggle-show-lines (screenxy->point x y))))
  208.   (bind '.board "<L>" 
  209.     (lambda (x y) (toggle-show-lines (screenxy->point x y))))
  210.   (bind '. "<Q>" (lambda () (quit)))
  211.   (bind '. "<q>" (lambda () (quit)))
  212.   (bind '. "<space>" new-game)
  213.   (bind '. "<m>" (lambda () (display moves) (newline)))
  214.   (focus '.board)
  215.   (for-each-4                ; draw plane
  216.    (lambda (i)
  217.      (draw-plane 0 (+ (* dely 4 i) (* distance i)))))
  218.   (let* ((bbox (.board 'bbox 'all))
  219.      (width (+ (- (caddr bbox) (car bbox)) x0 x0))
  220.      (height (+ (- (cadddr bbox) (cadr bbox)) y0 y0)))
  221.     (set! modx0 (- x0 (car bbox)))
  222.     (set! mody0 (- y0 (cadr bbox)))
  223.     (.board 'move 'all modx0 mody0)
  224.     (.board 'configure :width width :height height)
  225.     (pack '.note :expand #t :fill "x" :side 'bottom)
  226.     (pack '.board :expand #t :fill "both" :side 'bottom)
  227.     (pack '.mb :side 'left)
  228.     (pack '.help :side 'right))
  229.   (for-each-point1            ; draw point state sign
  230.    (lambda (point)
  231.      (let ((val (state-ref1 point)))
  232.        (if (not (= val empty-value))
  233.        (if (crosses? win-line point)
  234.            (draw-move point val 'highlight)
  235.            (if (or (and (not (null? moves))
  236.                 (point-equal? (car moves) point))
  237.                (and (not (null? (cdr moves)))
  238.                 (point-equal? (cadr moves) point)))
  239.            (draw-move point val 'last)
  240.            (draw-move point val)))))))
  241.   (let ((point shown-lines-point))    ; show lines if on
  242.     (set! shown-lines-point #f)
  243.     (show-lines point))
  244.   (note ""))
  245.  
  246. (define (about)
  247.   (catch (destroy .about))
  248.   (toplevel '.about)
  249.   (message '.about.m 
  250.        :width 250
  251.        :justify 'center
  252.        :text 
  253.        "3D Tic-Tac-Toe\n\
  254. by\n\
  255. Edin \"Dino\" Hodzic\n\
  256. mailto:ehodzic@scu.edu")
  257.   (button '.about.ok :text "OK" :command (lambda () (destroy '.about)))
  258.   (pack '.about.m :expand #t :fill 'both :side 'top)
  259.   (pack '.about.ok :side 'top))
  260.  
  261. ; reset the board size/angle
  262. (define (tune-reset)
  263.   (set! cell-width 15)
  264.   (set! cell-height 15)
  265.   (set-angle! 45))
  266.  
  267. ; show the resizing window
  268. (define (tune)
  269.   (catch (destroy '.tune))
  270.   (toplevel '.tune)
  271.   (scale '.tune.cw 
  272.      :label "Cell Width"
  273.      :variable 'cell-width 
  274.      :command (lambda (v) (set-angle! angle) (draw-board))
  275.      :relief 'sunken
  276.      :orient 'horizontal)
  277.   (scale '.tune.ch 
  278.      :label "Cell Height"
  279.      :variable 'cell-height
  280.      :command (lambda (v) (set-angle! angle) (draw-board))
  281.      :relief 'sunken
  282.      :orient 'horizontal)
  283.   (scale '.tune.an
  284.      :label "Angle"
  285.      :variable 'angle
  286.      :orient 'horizontal
  287.      :relief 'sunken
  288.      :to 180
  289.      :command (lambda (v) (set-angle! angle) (draw-board)))
  290.   (button '.tune.quit :text "Close"
  291.       :command (lambda () (destroy '.tune)))
  292.   (button '.tune.reset :text "Reset"
  293.       :command (lambda () (tune-reset) (draw-board)))
  294.   (pack '.tune.cw :fill 'x :side 'top)
  295.   (pack '.tune.ch :fill 'x :side 'top)
  296.   (pack '.tune.an :fill 'x :side 'top)
  297.   (pack '.tune.reset :fill 'x :side 'left)
  298.   (pack '.tune.quit :fill 'x :side 'right))
  299.  
  300. ; highlight the winning line
  301. (define (show-winning move)
  302.   (let ((val (state-ref1 move)))
  303.     (for-each-point-in-line        ; draw highlighed point
  304.      (lambda (point)
  305.        (draw-move point val 'highlight))
  306.      win-line)
  307.     (note (string-append 
  308.        "Game Over - " 
  309.        (if (= val comp-value) 
  310.            "I win!" 
  311.            "You win!")))))
  312.  
  313. ; show a note
  314. (define (note str)
  315.   (.note 'config :state 'normal)
  316.   (.note 'delete 0 'end)
  317.   (.note 'insert 0 str)
  318.   (.note 'config :state 'disabled))
  319.  
  320. ; clear up everything and restart the game
  321. (define (new-game)
  322.   (clear-state!)
  323.   (set! game-over #f)
  324.   (set! win-line #f)
  325.   (set! moves '())
  326.   (draw-board))
  327.  
  328. ;;; state and other game related variables
  329.  
  330.  
  331. (define signs (vector #f "o" "x"))    ; player signs
  332. (define game-over #f)            ; game over flag
  333. (define win-line #f)            ; the winning line
  334. (define empty-value 0)            ; available point value in the state
  335. (define user-value 1)            ; user value in the state vector
  336. (define comp-value 2)            ; compute value in the state vector
  337. (define state #f)            ; the board state
  338. (define moves '())            ; the list of all moves played
  339.  
  340. ;;; state access functions
  341.  
  342. (define (value->sign val) 
  343.   (vector-ref signs val))
  344.  
  345. (define (state-ref p r c)
  346.   (let ((ind (inexact->exact (+ c (* 4 (+ r (* 4 p)))))))
  347.     (vector-ref state ind)))
  348.  
  349. (define (state-ref1 point)
  350.   (state-ref (point-plane point)
  351.          (point-row point)
  352.          (point-column point)))
  353.  
  354. (define (state-set! p r c v)
  355.   (let ((ind (inexact->exact (+ c (* 4 (+ r (* 4 p)))))))
  356.     (vector-set! state ind v)))
  357.  
  358. (define (state-set1! point val)
  359.   (state-set! (point-plane point)
  360.           (point-row point)
  361.           (point-column point) val))
  362.  
  363. (define (clear-state!)
  364.   (set! state (make-vector 64 empty-value)))
  365.  
  366. ;;; playing functions
  367.  
  368. ; entry point on user click
  369. (define (action x y)
  370.   (let* ((user-move (screenxy->point x y)))
  371.     (if (and (not game-over) user-move)
  372.     (play user-move))))
  373.  
  374. (define (acceptable-move? move)
  375.   (and (not game-over)
  376.        (= (state-ref1 move) empty-value)))
  377.  
  378. ; play with user's move
  379. (define (play move)
  380.   (if (acceptable-move? move)
  381.       (begin
  382.     (note "")
  383.     (enter-move move user-value)
  384.     (if (won? move)
  385.         (show-winning move)
  386.         (let ((comp-move (make-move)))
  387.           (enter-move comp-move comp-value)
  388.           (if (won? comp-move)
  389.           (show-winning comp-move)
  390.           (if (draw?)
  391.               (note "It's a draw!"))))))
  392.       (note "Bad move")))
  393.  
  394. ; change the state and draw the move on the board
  395. (define (enter-move move val)
  396.   (if move
  397.       (begin
  398.     (state-set1! move val)
  399.     (set! moves (cons move moves))
  400.     (if (and 
  401.          (not (null? (cdr moves)))
  402.          (not (null? (cddr moves))))
  403.         (begin
  404.           (clear-move (caddr moves))
  405.           (draw-move (caddr moves) val 'plain)))
  406.     (draw-move move val 'last)
  407.     (update 'idletasks))))
  408.  
  409. ; take a move back
  410. (define (take-back-move)
  411.   (if (null? moves)
  412.       (note "No more moves")
  413.       (let ((take-one
  414.          (lambda ()
  415.            (if (not (null? moves))
  416.            (begin
  417.              (state-set1! (car moves) empty-value)
  418.              (clear-move (car moves))
  419.              (set! moves (cdr moves)))))))
  420.     (take-one)
  421.     (if (= (state-ref1 (car moves)) user-value)
  422.         (take-one)) ; one more for the user move
  423.     (set! game-over #f)
  424.     (set! win-line #f)
  425.     (draw-board))))
  426.  
  427. ; deciding among same score moves
  428. (define (doexchange?)
  429.   (= (random 5) 0))
  430.  
  431. ; find the best move
  432. (define (make-move)
  433.   (let ((best-score -1)
  434.     (best-move #f))
  435.     (for-each-point1
  436.      (lambda (point)
  437.        (if (= (state-ref1 point) empty-value)
  438.        (let ((score (score-if-played point)))
  439.          (if (or (> score best-score)
  440.              (and (= score best-score) (doexchange?)))
  441.          (begin
  442.            (set! best-score score)
  443.            (set! best-move point)))))))
  444.     best-move))
  445.  
  446. ; position evaluation
  447. (define (score-if-played point)
  448.   (let ((score 0))
  449.     (for-each 
  450.      (lambda (line)
  451.        (let ((user-count 0)
  452.          (comp-count 1))
  453.      (for-each-point-in-line
  454.       (lambda (point)
  455.         (let ((val (state-ref1 point)))
  456.           (cond 
  457.            ((= val comp-value)
  458.         (set! comp-count (1+ comp-count)))
  459.            ((= val user-value)
  460.         (set! user-count (1+ user-count))))))
  461.       line)
  462.      (cond ((= user-count 0) ; offensive
  463.         (begin
  464.           (set! score (+ score (vector-ref
  465.                     #(0 80 100 2000 100000)
  466.                     comp-count)))
  467.           (if (= comp-count 2)
  468.               (for-each-point-in-line
  469.                (lambda (p)
  470.              (if (and (= (state-ref1 p) empty-value)
  471.                   (not (point-equal? point p)))
  472.                  (for-each
  473.                   (lambda (line)
  474.                 (let ((user-count 0)
  475.                       (comp-count 0))
  476.                   (for-each-point-in-line
  477.                    (lambda (point)
  478.                      (let ((val (state-ref1 point)))
  479.                        (cond 
  480.                     ((= val comp-value)
  481.                      (set! comp-count (1+ comp-count)))
  482.                     ((= val user-value)
  483.                      (set! user-count 
  484.                            (1+ user-count))))))
  485.                    line)
  486.                   (if (and (= user-count 0)
  487.                        (>= comp-count 2))
  488.                       (set! score (+ score 800)))))
  489.                   (point-lines p))))
  490.                line))))
  491.            ((= comp-count 1) ; defensive
  492.         (set! score (+ score (vector-ref
  493.                       #(0 50 1500 10000)
  494.                       user-count)))))))
  495.      (point-lines point))
  496.     score))
  497.  
  498. ; checking if the game is won
  499. (define (won? move)
  500.   (let ((val (state-ref1 move)))
  501.     (for-each
  502.      (lambda (line)
  503.        (if (full-line? line val)
  504.        (set! win-line line)))
  505.      (point-lines move)))
  506.   (set! game-over win-line)
  507.   game-over)
  508.  
  509. ; is it a draw?
  510. (define (draw?)
  511.   (= (length moves) 64))
  512.  
  513. ;;; point functions
  514.  
  515. (define (make-point p r c)
  516.   (vector p r c))
  517.  
  518. (define (point-equal? p1 p2)
  519.   (and (= (point-plane p1) (point-plane p2))
  520.        (= (point-row p1) (point-row p2))
  521.        (= (point-column p1) (point-column p2))))
  522.  
  523. (define (point-plane point)
  524.   (vector-ref point 0))
  525.  
  526. (define (point-row point)
  527.   (vector-ref point 1))
  528.  
  529. (define (point-column point)
  530.   (vector-ref point 2))
  531.  
  532. (define (point->string point)
  533.   (string-append
  534.    (number->string (point-plane point))
  535.    ","
  536.    (number->string (point-row point))
  537.    ","
  538.    (number->string (point-column point))))
  539.  
  540. ;;; line functions
  541.  
  542. (define (complement x)
  543.   (- 3 x))
  544.  
  545. ; line templates:
  546. ; car is the predicate for the line to go through a point. 
  547. ; cdr is the line.
  548. (define line-tpl
  549.   (list
  550.    (cons 
  551.     (lambda (p r c) #t)
  552.     (lambda (p r c) (lambda (x)    (make-point p r x))))
  553.    (cons 
  554.     (lambda (p r c) #t)
  555.     (lambda (p r c) (lambda (x) (make-point p x c))))
  556.    (cons 
  557.     (lambda (p r c) #t)
  558.     (lambda (p r c) (lambda (x) (make-point x r c))))
  559.    (cons 
  560.     (lambda (p r c) (= r c))
  561.     (lambda (p r c) (lambda (x) (make-point p x x))))
  562.    (cons 
  563.     (lambda (p r c) (= r (complement c)))
  564.     (lambda (p r c) (lambda (x) (make-point p x (complement x)))))
  565.    (cons 
  566.     (lambda (p r c) (= p c))
  567.     (lambda (p r c) (lambda (x) (make-point x r x))))
  568.    (cons 
  569.     (lambda (p r c) (= p (complement c)))
  570.     (lambda (p r c) (lambda (x) (make-point x r (complement x)))))
  571.    (cons 
  572.     (lambda (p r c) (= p r))
  573.     (lambda (p r c) (lambda (x) (make-point x x c))))
  574.    (cons 
  575.     (lambda (p r c) (= p (complement r)))
  576.     (lambda (p r c) (lambda (x) (make-point x (complement x) c))))
  577.    (cons 
  578.     (lambda (p r c) (= p r c))
  579.     (lambda (p r c) (lambda (x) (make-point x x x))))
  580.    (cons 
  581.     (lambda (p r c) (= p r (complement c)))
  582.     (lambda (p r c) (lambda (x) (make-point x x (complement x)))))
  583.    (cons 
  584.     (lambda (p r c) (= p (complement r) c))
  585.     (lambda (p r c) (lambda (x) (make-point x (complement x) x))))
  586.    (cons 
  587.     (lambda (p r c) (= (complement p) r c))
  588.     (lambda (p r c) (lambda (x) (make-point (complement x) x x))))))
  589.  
  590. ; list of lines going through a point
  591. (define (point-lines point)
  592.   (let ((plane (point-plane point))
  593.     (row (point-row point))
  594.     (column (point-column point))
  595.     (lines '()))
  596.     (for-each
  597.      (lambda (tpl)
  598.        (if ((car tpl) plane row column)
  599.        (set! lines
  600.          (cons 
  601.           ((cdr tpl) plane row column)
  602.           lines))))
  603.      line-tpl)
  604.     lines))
  605.  
  606. ; whther line crosses point
  607. (define (crosses? line point)
  608.   (if line
  609.       (let ((crosses?
  610.          (lambda (return)
  611.            (for-each-point-in-line 
  612.         (lambda (line-point)
  613.           (if (point-equal? line-point point)
  614.               (return #t)))
  615.         line)
  616.            (return #f))))
  617.     (call/cc crosses?))
  618.       #f))
  619.  
  620. ;;; iterators
  621.  
  622. (define (for-each-4 func)
  623.   (for-each func '(0 1 2 3)))
  624.  
  625. (define (for-each-5 func)
  626.   (for-each func '(0 1 2 3 4)))
  627.  
  628. ; each point on the board (func plane row col)
  629. (define (for-each-point func)
  630.   (for-each-4
  631.    (lambda (plane)
  632.      (for-each-4
  633.       (lambda (row)
  634.     (for-each-4
  635.      (lambda (col)
  636.        (func plane row col))))))))
  637.  
  638. ; similar to the above (func point)
  639. (define (for-each-point1 func)
  640.   (for-each-point 
  641.    (lambda (plane row col)
  642.      (func (make-point plane row col)))))
  643.  
  644. ; for each point in a line call (func point)
  645. (define (for-each-point-in-line func line)
  646.   (for-each-4
  647.    (lambda (x)
  648.      (func (line x)))))
  649.  
  650. ; is the line full of value
  651. (define (full-line? line value)
  652.   (let ((full?
  653.      (lambda (return)
  654.        (for-each-point-in-line
  655.         (lambda (point)
  656.           (if (not (= (state-ref1 point) value))
  657.           (return #f)))
  658.         line)
  659.        (return #t))))
  660.     (call/cc full?)))
  661.  
  662. ;;; game initiation
  663.  
  664. (tune-reset)
  665. (new-game)
  666.